PROGRAM cadx

! Code converted using TO_F90 by Alan Miller
! Date: 2013-05-26  Time: 22:01:46

!-------------------------------------------------------------------------

!   Executive routine for program CADAC, Version 3.0  Date: June 2000


!--Program History--------------------------------------------------------

!  2000 Jun   Version update to coincide with new CADAC Studio

!  2000 Feb   Eliminated the MINIT variable in C(1600) to be greater than 99
!             for SWEEP cases.  In order to signal a SWEEP execution, a
!             SWEEP/NOSWEEP item must be added to the HEAD.ASC header.

!             Added error handler routine when reading CADIN.ASC file.
!             This alerts the user to the error record in the CADIN.ASC
!             file.  This routine also allows for full line comment records
!             indicated by the 04 in columns 1 and 2.
!             Subroutines changed: RDI1_PRIM_TRAJ
!                                  RDI1_16CARD
!                                  RDI2_RDCARD
!                                  SAV_INSTREAM

!  1999 Jun   Added a flag reset for reading from CSAVE.ASC file.  When the
!             run number flag, JRUN, is reset to 1 at the end of a multi-run
!             case, the ISAVE flag is also reset to indicate the start of
!             a new group trajectory.

!  1998 Sep   Default the CRITMAX value to zero unless CRITMAX enterd as
!             greater than CRITVAL.  This is will allow the SWEEP program
!             to pick up the T values as designated by TRCOND.

!             The critical variable output has been fixed with respect to
!             output on TABOUT.  If the SWEEP trajectory does not reach the
!             correct end (LCONV > 2) the CritMax value is written as the
!             critical variable value.

!             The test for the critical variable has been modified with respect
!             to the SWEEP modes.  The criteria testing starts with the
!             critical variable being less than the critical value.  This is
!             true for SWEEP modes 4 and 5 only.

!  1998 May   Removed the FUNCTION RANF to be kept in the UTL2.FOR file.

!             Changed the Unit ID for TABOUT back to 6 such that all output
!             will written to standard output or TABOUT only.  Using the
!             Digital FORTRAN compiler, all output will be written to
!             TABOUT if indicated by TABOUTASC keyword in the HEAD.ASC file
!             All output will be written to the screen by default if no TABOUT
!             file indicated.

!  1998 Apr   Added call to SWEEPI in subroutine AUXI for SWEEP initialization

!             Changed the Unit ID for the TABOUT (tabular output) file
!             from 6 to 8.  This change will allow data to be written to
!             tabout and the screen during CADAC executions.  This change was
!             brought about when using the Digital Visual FORTRAN v5.0A.
!             Previous versions of Microsoft FORTRAN allowed writing to unit 6
!             as a file and writing to * for screen output; this was not supported
!             in Digital's FORTRAN compiler.


!  1997 Sep   New output files created for use with the Real-Time CADAC
!             with associated file ids and flags.

!             New HEADER flags (for RT-CADAC) on the HEAD.ASC file:
!                 (NO)INITASC/(NO)INITBIN    Flags for RT initialization file
!                 (NO)TRACKASC/(N0)TRACKBIN  Flags for RT Track data file

!             New File IDS (for RT CADAC):
!                 ID_INITASC   - file ID for INIT.ASC  = 50
!                 ID_INITBIN   - file ID for INIT.BIN  = 51
!                 ID_TRACKASC  - file ID for TRACK.ASC = 60
!                 ID_TRACKBIN  - file ID for TRACK.BIN = 61

!             New output data files (for RT CADAC):
!                 INIT.ASC  - ascii RT initialization data file
!                 INIT.BIN  - binary RT initialization data file
!                 TRACK.BIN - ascii RT track data file
!                 TRACK.BIN - binary RT track data file

!             The read header plot variable routine (RDH1_PVAR) was
!             changed to incorporate the new column 1 values.
!             Column 1 is now to indicate if the variable on that record
!             will be used for the RT CADAC output files generated by CADAC.
!             An I in column 1 indicates the variable is to be used for the
!             initialization file (INIT.ASC/BIN).  A T indicates the
!             variable will be used for the track data file (TRACK.ASC/BIN).
!             A B indicates the variable will be used for both RT files.
!             The * comment record is maintained.

!             A new COMMON was added to send the First Time Write Flag to the
!             INIT.ASC/BIN file
!             COMMOM /FIRSTI/ FINIT (Logical)

!  1997 May   New Sweep methodology added: SWEEP5. This methodology now
!             records impact information for a complete miss and
!             performs a binary search as the trajectories are
!             generated.  This new method is not fully checked out at this
!             time and therefore, SWEEP5 is a beta release.

!             LCONV = 5 for end of trajectory by staging - set in STGE3

!             SWEEP.ASC   renamed to IMPACT.ASC
!             SWEEP7.ASC  renamed to IMPACT7.ASC
!             SWEEP10.ASC renamed to IMPACT10.ASC
!             ID_SWEEP    renamed to ID_IMPACT
!             ID_SWEEP7   renamed to ID_IMPACT7
!             ID_SWEEP10  renamed to ID_IMPACT10

!             For SWEEP mode 4 and 5 impact data is written to IMPACT.ASC
!             file for all trajectories, either "hit" or "miss".  For
!             "miss" trajectories, the critical value is replaced by
!             CRITMAX and this new value is written to output files.

!  1995 Mar   Program converted to MS F32 and the files were renamed
!             The program was renamed to CADX1.  Additional output
!             options were added to the first line of the HEAD.ASC
!             file:  TRAJBIN, NOTRAJBIN, TRAJASC, NOTRAJASC, STATBIN,
!             NOSTATBIN, STATASC, NOSTATASC, TABOUT, NOTABOUT.  In
!             addition, file unit numbers were changed to variables.

!  1993       Program converted to PC.
!             These modifications necessary to the conversion included:
!             *   Changing the tabout unit to standard output for file
!                 redirection control by the batch file.  Modifying the
!                 open statements to access Environment Variables
!                 instead of Logicals.
!             *   PC Version - this version corresponds to
!                 CADAC_EXEC2_6.FOR on the
!                 VAX for use with MS F32.

!  Aug 93     A problem was discovered with the RANSEED methodology.
!             Since the data is read from the input deck with a real number
!             and VAX real only keeps 7 sig digits, any seeds with more
!             than 7 digits could not be accurately/easily entered.
!             The code was modified to allow the user to enter the most
!             sig. 7 digits and add "01" as the least sig digits.  This
!             generated mods to options 1-3 of the RANSEED card entry.

!  XR 92      Modified the sweep methodology to allow multi-control
!             cards to be used with the sweep cards (ie. type 90, and 5)
!             NOTE: group cards were determined to be inappropriate when
!             used with sweep cards.
!             Test cases for 11 combinations were created and used
!             to test the valid methodology combinations with control
!             cards.
!             Also performed:
!             *  Modified the OPNORO flag and WEII3 variable assignment.
!                Default is OPNORO=0 => rotating earth model;
!             *  Insured that the EXEC code was compatible with EQSORT
!             *  Performed further code cleanup (removed LSTEP from
!                Exec); added more code comments.
!             *  Re-worked RANSEED initialization methodology to allow
!                single trajectories from multi-run cases to be
!                executed without executing the entire run set.
!             *  Discovered a problem with the RANF function on the
!                MicroVax so replaced system RANF with an inline module
!                that is based on the Fortran Intrinsic function RAN.
!                RANF provides uniform random values between (0,1),
!                exclusive of both 0 and 1.
!             *

!  SEU 91-08  Executive code updated.  Final version named CADAC_EXEC1.
!             Code updated documented in ER-TC-SEU 91-08,
!             PROGRAM CADAC: UPGRADE 1
!             Modifications included:
!             *  Futher comments added and code sturcturing performed.
!             *  All output/input files opened using logicals but also
!                have default names when logicals undefined.
!             *  Sweep modules were restructured and commented to allow
!                more flexibility.  Options for the sweep searchings
!                methodology were commented and corrected as needed.
!                Operations were verified.  Card types changed to 19,
!                20 and 21
!             *  A methodology for defining vectors in the C array was
!                implemented as well as the type 7 card for initializing
!                the vector
!             *  Warning messages were added to the modified Euler
!                integration module, AMRK.
!             *  Type 4 card added - comment card.

!  SEU 91-02  Executive received from Dr. Zipfel.  The executive was
!             utilized in the task and the following modifications
!             were performed:
!             *  Structured code elements were substituded for
!                non-structured code elements where applicable
!             *  Comments were added
!             *  Code was broken into modules
!             *  Head.ASC (unit 3) was opened with "readonly" status
!             *  RANSEED variable was added for initialization of random
!                function generator and code to perform the
!                initialization was added to the exec.
!             *  RAYLE, RAYLEI, EXPO and SIGN functions added to type 11
!                and type 3 cards.

!  NOTE:  The cadac executive prints whatever values are in the C location
!         to the trajectory and statistics files.  Any manipulation
!         to the data to produce "interpolated" values at impact must be
!         done by the modules (ie. G4); it is NOT performed here.


!--File Usage------------------------------------------------------------

!  Unit         Logical/file Name  Notes

!   ID_HEAD     HEAD               (I)   Parameter Definition
!   ID_CADIN    CADIN              (I)   Input records (lead cards)
!   ID_IMPACT7  IMPACT7.ASC        (I/O) Scratch.
!   ID_IMPACT10 IMPACT10.ASC       (I/O) Scratch.
!   ID_IMPACT   IMPACT.ASC         (O)   Sweep end results.
!   ID_TRAJBIN  TRAJBIN            (O)   binary trajectory data
!   ID_TRAJASC  TRAJASC            (O)   ascii trajectory data

!   ID_TABOUT   TABOUT             (O)   Output records / scroll to screen
!                                        This was the original VAX version;
!                                        unit 36 was opened with a file named
!                                        "sys$output" when screen display was
!                                        desired.  As this could not be
!                                        duplicated on the PC, the unit
!                                        was changed to *, standard output,
!                                        and the file direction set by the
!                                        command/batch file executing CADAC.
!  ID_STATBIN   STATBIN            (O)  binary tatistical data
!  ID_STATASC   STATASC            (O)  binary tatistical data
!  ID_CSAVE     CSAVE.ASC          (O) Saved state file (optional)

!--Program Format Notes-------------------------------------------------

!  *  WRITE Statements containing the string "%%%" were used for debug
!     purposes only.  These statements are commented out for final releases
!     but were left in.  The information may be useful in later analysis.


!  For compatibility with the utility programs in the CADAC series, the
!  following program format rules must be followed:

!  * Full comment lines must use the C in column 1, NOT the !.  Inline
!    comments are permitted, but NOT on Equivalence or Dimension
!    statements.

!  * Equivalence statements must be consecutive in blocks; NO COMMENT
!    Lines (even blank comment lines) or other statements may be included
!    within the blocks.  The blocks may be divided into the following
!    predefined catagories:
!      INPUT FROM OTHER MODULES
!      INPUT DATA
!      OUTPUT
!      DIAGNOSTICS
!    Blank comment lines are used to indicate the start/end of a block
!    of equivalence statements.


!  This is the main "subroutine" for program cadac.

!--------------------------------------------------------------------

CALL exec


STOP
END PROGRAM cadx
BLOCK DATA aainit

!-------------------------------------------------------------------------

!  This subroutine performs common initialization prior to execution of
!  CADAC

!-------------------------------------------------------------------------

COMMON /ccom/    icf(25), icc(25), icl(25), ca(25),  &
    cl(25), ct0(25), nc, icl2(25)

COMMON /coller/  hol(5)
CHARACTER (LEN=80) :: hol

COMMON /flag1/   initgauss
LOGICAL :: initgauss

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /firsti/ finit
LOGICAL :: finit

COMMON /hcom/    title
CHARACTER (LEN=100) :: title

COMMON /ipsav/   ncards, nhol, jtypes(500), locs(500),  &
    mods(500), va1s(500), va2s(500), mod2(500)

COMMON /ipsavc/  als(3,500), hols(5)
CHARACTER (LEN=80) :: hols chara ter*6 als

COMMON /ipsvsc/  mcris(20,2,4), vals(20,2)

COMMON /ipsvst/  jtsts(20,60), locsts(20,60), modsts(20,60),  &
    va1sts(20,60), va2sts(20,60), mod2st(20,60), ncd(20)

COMMON /ipsvstc/ alsts(20,3,60)
CHARACTER (LEN=6) :: alsts

COMMON /ipsvscc/ mcrisc(20,2,2)
CHARACTER (LEN=6) :: mcrisc

COMMON /ipsvwd/  nwd, wxs(6,50)

COMMON /krun/    jrun, mulrun, igroup

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /oindat/  j16, icd, i16

COMMON /opinit/  iplinit(70), intpinit(70), ninitvar
LOGICAL :: intpinit

COMMON /opinitc/ initlab
CHARACTER (LEN=1) :: initlab(70)*8

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /opflgc/  fmtstring, trace
CHARACTER (LEN=1) :: fmtstring*85, trace(16)*8

COMMON /opplot/  ipladd(70), intplot(70)
LOGICAL :: intplot

COMMON /oppltc/  alable
CHARACTER (LEN=1) :: alable(70)*8

COMMON /opsvar/  iscrol, kloc(16), lprt, iheadp, ints(16)
LOGICAL :: ints

COMMON /optrack/  ipltrack(70), intptrack(70), ntrackvar
LOGICAL :: intptrack

COMMON /optrackc/ tracklab
CHARACTER (LEN=1) :: tracklab(70)*8

COMMON /prev/    tprev, cpprev, ppprev

COMMON /rundat/  irun

COMMON /stage/   loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest

COMMON /stage1/  istage, numstage

COMMON /stagec/  name1(2), name2(2)
CHARACTER (LEN=6) :: name2 chara ter*6 name1

COMMON /winds/   walt(50), wdir(50), wvel(50), rhx(50),  &
    ctmp(50), wpres(50), nwindr, rhw

COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al

COMMON /wsetsc/  mcri(20,2,4), wval(20,2)

COMMON /wsetscc/ mcric(20,2,2)
CHARACTER (LEN=6) :: mcric

COMMON /wsetst/  ncdw(20), jtst(20,60), locst(20,60),  &
    modst(20,60), va1st(20,60), va2st(20,60), m2st(20,60)

COMMON /wsetstc/ alst(20,3,60)
CHARACTER (LEN=6) :: alst

COMMON /wsetwt/  wx(6,50)


!-----------------------------

!     The blank common : C(3510)
!     The C variables defined here are those used by the executive
!     routine;  those c variables assigned to the modules are not
!     defined here as the definition varies depending on the modules
!     used (and written by the user).

!      C(0001) = ERRVAL (Amrk) The maximum integration step error value
!      C(0002) = ERRN   (Amrk) IPL element number of var causing ERRVAL
!      C(0003) = AERR  (Amrk) C element number of var causing ERRVAL
!      C(0004) = PRELOC (Amrk) Previous C element number causing ERRVAL

!      C(0051) = REARTH (Exec) Radius of the Earth in user-sel units
!      C(0052) = CRAD (Exec) Conversion factor. (Degrees / Radians)
!      C(0053) = OPTMET (EXEC) Units of measure 1 = metric; 0 = English
!      C(0054) = AGRAV (Exec) Acceleration due to gravity @ sea level
!      C(0055) = CFTM (Exec) Conversion factor. (Meters / Feet)
!      C(0056) = CKFPS (Exec) Conversion factor. (Knots / ( ft/sec.) )
!      C(0057) = AMU (Exec) Gravitational parameter mu for the Earth (ft^3/sec^2)
!      C(0058) = WEII3 = omega = angular rotation of the earth (rad/sec)
!      C(0059) = OPNORO - Option flag:  0 = rotating earth model
!                WEII3 = 7.2921154E-05;   1 = Non-rotating earth model
!                WEII3 = 0.0

!      C(0090) = RANSEED (Exec) Random function generator initialization.
!                Added under SEU 91-02, this value is used to initialize
!                the system's random number generator.

!      C(1772) = TRCOND (G4) Termin. Condit Codes from right to left.

!      C(1800) = ISWEEP - (Swp) Sweep option flag (0 through 5)
!      C(1801) = CRITNO - (Swp) Critical variable C location
!      C(1802) = CRITVAL - (Swp) Minimum test for critical variable
!      C(1803) = SEARNO - (Swp) Number of binary searche runs (opt 4 and 5)
!      C(1804) = NUMR - (Swp) The number of trajectory runs
!      C(1805) = CRITMAX - (Swp) The maximum test for critical variable
!      C(1811) = ANGLNO - (swp) The C location of the angluar variable
!      C(1812) = ANGMIN - (Swp) The minimum angle value
!      C(1813) = ANGMAX - (Swp) The maximum angle value
!      C(1814) = ANGDEL - (Swp) The Delta angle
!      C(1815) = ANGUNT - (Swp) The units of the input data: rad or deg
!      C(1821) = RANGNO - (Swp) The C location of the range variable
!      C(1822) = RANMIN - (Swp) The minimum range value
!      C(1823) = RANMAX - (Swp) The maximum range value
!      C(1824) = RANDEL - (Swp) The delta range value

!      C(2000) = TIME = Current integration Time in the trajectory.
!      C(2001) = TSTAGE = ? Time when the last stage occurred.
!      C(2003) = PCNT = Time of the next print to TABOUT
!      C(2004) = PPNT = Time of next print to the plot files.
!                (traj.* and stat.*)
!      C(2005) = PPP (Exec) Frequency (time) of writing the plot data.
!      C(2006) = ITAP90 (Exec) A Flag: 0 = No CSAVE.ASC; 1 = trajectory
!                started from data saved to CSAVE.ASC. (Used by D3I)
!      C(2011) = KSTEP (EXEC) Controls flow after an integration step.
!      C(2014) = ITCNT (Exec) Print flag counter
!      C(2015) = CPP (Exec) Frequency (time) of writing TABOUT data
!      C(2016) = PGCNT (Exec) Page counter flag
!      C(2020) = LCONV (Exec) Flag: 0 = start of traj; 2 = Stop calculations
!      C(2127 - 2196) = PMIN(1 - 70)
!      C(2280) = NV = The number of variables in the plot list.
!      C(2285) = NJ   Number of state variables to be integrated
!      C(2361) = NOMOD Number of modules to be called
!      C(2362 - 2460) = XMODNO(1 - 99) Array containing modules numbers to be called
!      C(2461) = NOSUB  Module number to be called
!      C(2462 - 2560) = SUBNO(1 - 99)  Array of module numbers
!      C(2561) = NIP - The number of variables being integrated
!      C(2562 - 2661) = IPL(1 - 100) The locations of the derivative of
!                       the state variable.
!      C(2662) = HMIN  Minimum integration value ?
!      C(2663) = HMAX  Maximum integration value ?
!      C(2664 - 2764) = DER(1 - 101) (Exec) Frequency of integration ?f
!      C(2765 - 2865) = V(1 - 101)
!      C(2866) = ICOOR
!      C(2867-2967) = IPLV(1-100) The location of the state variable;
!                     corresponding to the derivative in the IPL array.


!      DATA C/ 3510 * 0.0 /

!-----------------------------

!      /CCOM/ :
!       ICF(25) - (I) The function type for each defined functions
!       ICC(25) - (I) The combination code for each defined functions
!       ICL(25) - (I) The controlled variable for each defined function
!       CA(25)  - (R) The 1st parameter for each defined function
!       CL(25)  - (R) The 2nd parameter for each defined function
!                 (Modified by C11_process for the GAUSS function)
!       CT0(25) - (R) The time the function is defined. (Set to 0.0
!                 for the GAUSS function)
!          The above array index is from 1 to NC where:
!       NC - (I) Number of forcing functions that have been defined by
!            type 11 input cards.
!       ICL2(I) - (I) The second integer from the input stream =
!                 activated under task SEU 91-02.  May have different
!                 uses depending on the function's definition.

DATA icf/ 25 * 0 /, icc/ 25 * 0 /, icl/ 25 * 0 /, ca/ 25 * 0.0/,  &
    cl/ 25 * 0.0 /, ct0/ 25 * 0.0 /, nc / 0 /, icl2/ 25 * 0 /

!-----------------------------

!     /FLAG1/ :
!        INITGAUSS - (L) Flag for forcing the calculation of random
!                    deviates in the GAUSS module.  .T. = An unused
!                    random deviate is ready for use;  .F. = Need to
!                    calculate another pair.

DATA  initgauss/ .false. /

!-----------------------------

!     /HCOM/ :
!     TITLE = (C100) The input data title written to the TRAJ.* and
!             STAT.* files.

DATA title/ ' '  /

!-----------------------------

!     /IPSAV/ :
!     NCARDS = (I) The number of cards in the stage deck that form the
!              trajectory initialization (ie all cards prior to the
!              first card type 6 or 12).  These cards are saved in
!              special save arrays and reused at the start of each
!              trajectory rerun.
!     NHOL   = (I) Number of header cards entered in the input card deck.
!              (during the trajectory initialization)
!     These arrays are storage arrays that contain the data from the
!     input initialization cards.  The initialization cards are the input
!     cards until the first card type 6 or 12 is reached.  The main card
!     data is stored in these arrays and reloaded at the beginning of
!     each trajectory in multi trajectory run cases.
!     JTYPES(500) - (I) Contains the first integer (card types) from
!                   the input cards.
!     LOCS(500)   - (I) Contains the second integer from the input card.
!     MODS(500)   - (I) Contains the third integer from the input card.
!     VA1S(500)   - (R) Contains the first real from the input card.
!     VA2S(500)   - (R) Contains the second real from the input card.
!     MOD2(500)   - (I) Contains a fourth integer from the input card.
!     For the above arrays, the index is the card number from 1 to
!     NCARDS.

DATA ncards/ 0 /, nhol/ 0 /, jtypes/ 500 * 0 /, locs/ 500 * 0 /,  &
    mods/ 500 * 0 /,  va1s/ 500 * 0.0 /, va2s/ 500 * 0.0 /, mod2/ 500 * 0 /


!-----------------------------

!     /IPSAVC/
!     These arrays are storage arrays that contain the CHARACTER data from
!     the initialization cards.  The initialization cards are the input
!     cards until the first card type 6 or 12 is reached.  The main card
!     data is stored in these arrays and reloaded at the beginning of
!     each trajectory in multi trajectory run cases.
!     ALS(3,500) - (C6) Storage array containing the 3 sets of
!                  character data entered with the input initialization
!                  cards.  Index = 1, NCARDS
!     HOLS(5)    - (C80) Storage array containing the character data
!                  entered with a type 9 card with the initialization
!                  cards. (Index = 1, NHOLS )

DATA als/ 1500 * '      ' /, ( hols(j), j=1,5)/ 5 * ' '  /

!-----------------------------

!     /IPSVSC/ :
!     These arrays are storage arrays that contain the data from
!     the type 10 (Stage Criteria) cards within the initialization
!     card set. The initialization cards are the input cards until the
!     first card type 6 or 12 is reached.  The card data is stored in
!     these arrays and reloaded at the beginning of each trajectory in
!     multi trajectory run cases.   MAXIMUM NUMBER OF STAGES = 20
!     MCRIS(20,2,4) - (I) Contains integer data from the type 10 cards.
!     VALS(20,2)    - (R) Contains real data from the type 10 cards.

DATA mcris/ 160 * 0 /, vals/ 40 * 0.0 /

!-----------------------------

!     /IPSVSCC/ :
!     This arrays is a storage array that contains the CHARACTER data
!     from the type 10 (Stage Criteria) cards within the initialization
!     card set. The initialization cards are the input cards until the
!     first card type 6 or 12 is reached.  The card data is stored in
!     these array and reloaded at the beginning of each trajectory in
!     multi trajectory run cases.  MAXIMUM NUMBER OF STAGES = 20
!     MCRISC(20,2,2) - (C6) Storage array containing the 2 sets of
!                      character data for the type 10 cards from the
!                      initialization deck.
DATA mcrisc/ 80 * '      ' /

!-----------------------------

!     /IPSVST/ :
!     These arrays are storage arrays that contain the data from
!     the STage cards within the initialization card set. The
!     initialization cards are the input cards until the first card
!     type 6 or 12 is reached.  These cards are executed at the beginning
!     of a trajectory for each multirun/montecarlo run. The data is
!     transferred from these arrays to the working set of arrays at the
!     begining of each run.  Any data entered by a type 12 card is then
!     applied to the cards.  N = 1-20 = stage number; NN = 1-60 = card
!     number for the set of cards in stage N = 1 to NCD( N )
!     JTSTS(20,60)  - (I) First integer from card data = cardtype.
!     LOCSTS(20,60) - (I) Second integer from the card data.
!     MODSTS(20,60) - (I) Third integer from the card data.
!     VA1STS(20,60) - (R) First real value from the card input data.
!     VA2STS(20,60) - (R) Second real value from the card input data.
!     MOD2ST(20,60) - (I) Fourth integer from the card data.
!     NCD(20)       - (I) Number of cards for stage N following the type
!                      16 card until a type 6, 10 or 12 card occurrs.
!                      This is the max NN values for the above storage
!                      arrays.

DATA jtsts/ 1200 * 0 /, locsts/ 1200* 0 /, modsts/ 1200* 0 /,  &
    va1sts/ 1200* 0.0 /, va2sts/ 1200 * 0.0/, mod2st/ 1200 * 0 /, ncd/ 20 * 0 /

!-----------------------------

!     /IPSVSTC/ :
!     These arrays are storage arrays that contain the CHARACTER data
!     from the STage cards within the initialization card set. The
!     initialization cards are the input cards until the first card
!     type 6 or 12 is reached.  These cards are executed at the beginning
!     of a trajectory for each multirun/montecarlo run. The data is
!     transferred from these arrays to the working set of arrays at the
!     begining of each run.  Any data entered by a type 12 card is then
!     applied to the cards.  N = 1-20 = stage number; NN = 1-60 = card
!     number for the set of cards in stage N = 1 to NCD( N )
!     ALSTS(20,3,60) - (C6) A storage array containing the character
!              data from the input cards.  This arrays belongs with the
!              storage set of arrays : JTSTS, LOCSTS, MODSTS, etc, found in
!              common /IPSVST/. See these variable definitions for more
!              information.

DATA alsts/ 3600 * ' ' /

!-----------------------------

!     /IPSVWD/ :
!     This array is a storage array that contains the WEATHER data
!     within the initialization card set. The initialization cards are
!     the input cards until the first card type 6 or 12 is reached.
!     These cards are executed at the beginning of a trajectory for
!     each multirun/montecarlo run. The data is transferred from these
!     arrays to the working set of arrays at the begining of each run.
!     NWD - (I) The number of atmospheric data sets read into the
!                 WXS array.
!     WXS(6,50) - (R) Contains the atmospheric data as read from the
!                input cards.  WXS(I,J) : I => 1 = Altitude, 2 =
!                Wind Direction, 3 = Wind Velocity, 4 = Density,
!                5 = Temperature, 6 = Pressure
!                Up to J=50 sets of atmospheric data may be entered.

DATA nwd/ 0 /, wxs/ 300 * 0.0 /


!-----------------------------

!     /KRUN/ :
!     JRUN   - (I) Run number/counter for the multi-run cases.
!     MULRUN - (I) Flag that indicates if case is a multi-run case or
!              not:  0 = NOT multi-run case;  N = Number of runs in
!              the Multi-run case.
!     IGROUP - (I) The group number/counter

DATA jrun/ 1 /, mulrun/ 0 /, igroup/ 1 /

!-----------------------------

!      /NAD/   :
!      IBEEN,
!      IBEGIN - (I) The Stage number where a save of C to tape 90
!               occurred.
!      ICARD  - (I) The card number where a save of C to tape 90
!               occurred.
!      ISAVE  - (I) Flag: indicates that the C array has been saved to tape
!               90

DATA ibeen/ 0 /, ibegin/ 0 /, icard/ 0 /, isave/ 0 /

!-----------------------------

!     /OINDAT/  :
!      J16  - (I) FLAG: 0 = Pull card data from the main trajectory
!             arrays;  1 = Pull card data from the stage data arrays.
!      ICD  - (I) Counter.  The card number for the main trajectory
!             arrays, of the card currently being processed by OINPT1
!      I16  - (I) Counter.  The card number for the stage arrays, of the
!             card currently being processed by OINPT1.

DATA j16/ 0 /, icd/ 0 /, i16/ 0 /

!-----------------------------

!     /OPFLAG/ :
!     INTMSG    = (L) T= Print integration error messages to both
!                        sys$output and tabular output (?).  F= supress
!                        integration error message displays.
!     STGMSGOUT = (L) T= Print stage messages to Tabout file;
!                     F= supress staging messages.
!     INECHO    = (L) T= Echo the input to the output file;
!                     F= supress the echo of the input deck.
!     XSWEEP    = (L) T= Execution is a SWEEP run
!                     F= Execution is not a SWEEP run

DATA intmsg/ .false. /, stgmsgout/ .false. /, inecho/ .true. /  &
    xsweep/ .false. /

!-----------------------------
!     /FILEFLG/

!     TRAJBIN   = (L) T= create binary trajectory file
!                     F= don't create binary trajectory file
!     TRAJASC   = (L) T= create ascii trajectory file
!                     F= don't create ascii trajectory file
!     STATBIN   = (L) T= create binary statistics file
!                     F= don't create binary statistics file
!     STATASC   = (L) T= create ascii statistics file
!                     F= don't create ascii statistics file
!     TABOUT    = (L) T= create output to TABOUT.ASC
!                     F= write output to screen
!     RANVAR    = (L) T= Print type 3 and type 11 random value
!                        assignments of variables to unit 37 = RANVAR.ASC
!     INITASC   = (L) T= create ascii RT initializtion file
!                     F= don't create ascii RT initializtion file
!     INITBIN   = (L) T= create binary RT initializtion file
!                     F= don't create binary RT initializtion file
!     TRACKASC  = (L) T= create ascii RT track data file
!                     F= don't create ascii RT track data file
!     TRACKBIN  = (L) T= create binary RT track data file
!                     F= don't create binary RT track data file
DATA trajbin/.false./, trajasc/.false./, statbin/.false./,  &
    statasc/.false./, tabout/.false./,  ranvar/ .false. /,  &
    initasc/.false./, initbin/.false./, trackasc/.false./, trackbin/.false./

!-----------------------------
!      /FILEIDS/
!      ID_CADIN    (I) - file id for input file CADIN.ASC
!      ID_HEAD     (I) - file id for input head.asc
!      ID_CSAVE    (I) - file id for saved states file
!      ID_TRAJBIN  (I) - file id for binary trajectory file
!      ID_TRAJASC  (I) - file id for ascii trajectory file
!      ID_STATBIN  (I) - file id for binary statistics file
!      ID_STATASC  (I) - file id for ascii statistics file
!      ID_TABOUT   (I) - file id for tabular output file
!      ID_RANVAR   (I) - file id for random variable file
!      ID_INITASC  (I) - file id for ascii RT CADAC initialization file
!      ID_INITBIN  (I) - file id for binary RT CADAC initialization file
!      ID_TRACKASC (I) - file id for ascii RT CADAC track data file
!      ID_TRACKBIN (I) - file id for binary RT CADAC track data file


DATA id_cadin/35/,   id_head/ 3/ ,   id_csave/90/, id_tabout/6/
DATA id_trajbin/11/, id_trajasc/12/
DATA id_statbin/44/, id_statasc/45/
DATA id_ranvar/37/
DATA id_impact/22/,   id_impact7/ 7/,  id_impact10/10/
DATA id_initasc/50/, id_initbin/51/
DATA id_trackasc/60/, id_trackbin/61/

!-----------------------------

!     /OPFLGC/ :
!     FMTSTRING  = (C) Contains the format to use when printing the
!                  scroll variables.
!     TRACE(16)  = (C8) Scroll variable parameter name (acronym).

DATA fmtstring/ ' ' /,  trace/ 16 * ' ' /

!-----------------------------

!     /OPPLOT/:
!     IPLADD(70) = (I) Contains the list of C common locations to be
!                  printed to the plot data file. (TRAJ.*/STAT.*)
!     INTPLOT(70) = (L) Flag indicating if the plot variable is a real
!                  variable (.false.) or an integer variable (.true.)

DATA ipladd/ 70 * 0 /, intplot/ 70 * .false. /


!-----------------------------

!     /OPPLTC/:
!     ALABLE(70) = (C8) Contains the aronyms of the C common locations
!                  that are to be printed to the plot data file.
!                  (TRAJ.*/STAT.*)

DATA  alable/ 70 * '        ' /

!-----------------------------

!     /OPINIT/:
!     IPLINIT(70)  = (I) Contains the list of C common locations to be
!                    printed to the RT initialization file. (INIT.ASC/BIN)
!     INTPINIT(70) = (L) Flag indicating if the plot variable is a real
!                    variable (.false.) or an integer variable (.true.)
!     NINITVAR     = (I) The number of variables to be plotted on the
!                    RT initialization data file

DATA iplinit/ 70 * 0 /, intpinit/ 70 * .false. /


!-----------------------------

!     /OPINITC/:
!     INITLAB(70) = (C8) Contains the aronyms of the C common locations
!                   that are to be printed to the RT initialization file.
!                   (INIT.ASC/BIN)

DATA  initlab/ 70 * '        ' /


!-----------------------------

!     /FIRSTI/:
!     FINIT = (L) Flag inidicating to write to INIT.ASC file the first time
!                 the C array is loaded with the intialization data

DATA finit/.true./


!-----------------------------

!     /OPSVAR/ :
!     ISCROL   = (I) Flag: 0 = NO scroll variables; 1 = Scroll
!                variables defined, display them on the screen/output.
!     KLOC(16) = (I) C element location of the scroll variables.
!     LPRT     = (I) Number of scroll variables.
!     IHEADP   = (I) Counts the number of lines printed to output
!                under the SCROLL option.  The counter used for
!                displaying the header information every 10 data
!                lines.
!     INTS(16) = (L) Integer flag indicating whether the scroll variable
!                is a real number (= 0 ) or an integer number ( = 1)

DATA iscrol/ 0 /, kloc/ 16 * 0 /, lprt/ 0 /, iheadp/ 0 /, ints/ 16 * .false. /

!-----------------------------

!     /OPTRACK/:
!     IPLTRACK(70)  = (I) Contains the list of C common locations to be
!                     printed to the RT track data file. (TRACK.ASC/BIN)
!     INTPTRACK(70) = (L) Flag indicating if the plot variable is a real
!                     variable (.false.) or an integer variable (.true.)
!     NTRACKVAR     = (I) The number of variables to be plotted on the
!                     RT track data file

DATA ipltrack/ 70 * 0 /, intptrack/ 70 * .false. /


!-----------------------------

!     /OPTRACKC/:
!     TRACKLAB(70) = (C8) Contains the aronyms of the C common locations
!                    that are to be printed to the RT track data file.
!                    (TRACK.ASC/BIN)

DATA  tracklab/ 70 * '        ' /

!-----------------------------


!      /PREV/ :
!      TPREV  - (R) The time the previous stage occurred.
!      CPPREV - (R) The saved tabular print interval.  Used to detect
!               whether the CPP value has been modified or not.
!      PPPREV - (R) The saved plot print interval.  Used to detect
!               whether the PPP value has been modified or not.

DATA tprev/ 0.0 /, cpprev/ 0.0 /, ppprev/ 0.0 /

!-----------------------------

!      /RUNDAT/  :
!      IRUN  - (I) Counter for the runs executed in the sweep methodology.

DATA irun/ 0 /


!-----------------------------

!      /STAGE/  :
!      LOC(2)   - (I) C element location of the staging variable
!      INCRS(2) - (I) Flag to determine relationship of staging variable
!                 value to staging criteria.  0 : <=  ;  1 : >=
!      VAL(2)   - (R) The (KODE=0) the staging criteria; (KODE>0) the C
!                 element containing the staging criteria; (KODE<0) an
!                 amount added to the original value of the LOC variable
!                 (prior to the stage) giving the staging criteria.
!      UNITS(2) - (R) Unused at this point ?
!      KODE(2)  - (I) Flag to determine how the VAL data is to be used
!      TEST(2)  - (R) (KODE<=0) The staging test criteria
!      LOCT(2)  - (I) (Kode>0) The C element containing the staging test
!                 criteria
!         For the above arrays, the index = 1, NTEST, the number of
!         staging tests.
!      NTEST    - (I) The number of staging tests (Max=2)

!      DATA LOC(2), INCRS(2), VAL(2), UNITS(2), KODE(2),
!     1                TEST(2), LOCT(2), NTEST

!-----------------------------

!      /STAGE1/ :
!      ISTAGE   - (I) Flag: 0 = Start of the trajectory;  16 = Execute
!                 until the stage criteria is met;  6 = Execute until end
!                 of trajectory.
!      NUMSTAGE - (I) The number of the stage currently being processed.

DATA istage/ 0 /, numstage/ 0 /

!-----------------------------

!      /STAGEC/ :
!      NAME1(2) - (C6) The input variable name of the staging variable
!      NAME2(2) - (C6) (Kode>0) The input variable name of the variable
!                 whose value is to be used as the staging criteria.

!      DATA NAME1(2), NAME2(2)

!-----------------------------

!     /WINDS/
!     WALT(50)
!     WDIR(50)
!     WVEL(50)
!     RHX(50)
!     CTMP(50)
!     WPRES(50) -
!     NWINDR -    (I) Dummy variable to keep alignment with this common
!                 block in the modules.
!     RHW


!-----------------------------

!     /WSET/ :
!      These arrays contain the working set of the lead trajectory
!      cards.  They are initialized by being set to the saved
!      initialization arrays (contain the original initialization cards
!      read from input), then the cards for the current trajectory group
!      are added or modify this set accordingly.
!     NCARD - (I) The number of cards in the working set.  Initialized
!              to the number of cards in the saved set (ncards), then
!              incremented for each card pertaining to the current
!              trajectory.
!     JTYPE(J) - (I)
!     LOCA(J)  - (I)   -- See the IPSAV common variables for definitions
!     MOE(J)   - (I)
!     VA1(J)   - (R)
!     VA2(J)   - (R)
!     M2(J)    - (I)
!      For the above variables, J = 1, NCARD with a maximum of 500.

DATA ncard/ 0 /, jtype/ 500 * 0 /, loca/ 500 * 0 /,  &
    moe/ 500 * 0 /, va1/ 500 * 0.0 /, va2/ 500 * 0.0 /, m2/ 500 * 0 /

!-----------------------------

!     /WSETC/ :
!      These arrays contain the working set CHARACTER data for the
!      lead trajectory cards.  They are initialized by being set to
!      the saved initialization arrays (contain the original
!      initialization cards read from input), then the cards for the
!      current trajectory group are added or modify this set accordingly.
!      See common /IPSAVC/ for definitions.
!      AL(3,500)     - (C6)
!      HOLL(5)       - (C80)

DATA al/ 1500 * ' ' /, holl/ 5 * ' ' /

!-----------------------------

!     /WSETSC/  :
!     These arrays contain the working set trajectory data from
!     the type 10 (Stage Criteria) cards.
!     MCRI(20,2,4) - (I) Contains integer data from the type 10 cards.
!     WVALS(20,2)    - (R) Contains real data from the type 10 cards.

DATA mcri/ 160 * 0 /, wval/ 40 * 0.0 /

!-----------------------------

!     /WSETSCC/ :
!      MCRIC(20,2,2) - (C) This array contains the working set
!                      trajectory CHARACTER data from the type 10

DATA mcric/ 80 * ' ' /

!-----------------------------

!      /WSETST/ :
!     These arrays are the working arrays that contain the data from
!     the STage cards.  See common /IPSVST/ for definitions.
!     NCDW(20) - (I)
!     JTST(20,60)  - (I)
!     LOCST(20,60) - (I)
!     MODST(20,60) - (I)
!     VA1ST(20,60) - (R)
!     VA2ST(20,60) - (R)
!     M2ST(20,60)  - (I)

DATA jtst/ 1200 * 0 /, locst/ 1200 * 0 /, modst/ 1200 * 0 /,  &
    va1st/ 1200 * 0.0 /, va2st/ 1200 * 0.0/, ncdw/ 20 * 0 /, m2st/ 1200 * 0.0 /

!-----------------------------

!     /WSETSTC/ :
!     This array is the working set array containing the CHARACTER data
!     from the STage cards.  N = 1-20 = stage number; NN = 1-60 = card
!     number for the set of cards in stage N = 1 to NCD( N )
!     ALST(20,3,60) - (C6) A storage array containing the character
!              data from the input cards.  This arrays belongs with the
!              storage set of arrays : JTST, LOCST, MODST, etc, found in
!              common /WSETST/ See these variable definitions for more
!              information.

DATA alst/ 3600 * ' ' /

!-----------------------------

!     /WSETWT/  : WX(6,50)
!     This array is a working array that contains the WEATHER data.
!     WX(6,50) - (R) Contains the atmospheric data as read from the
!                input cards.  WX(I,J) : I => 1 = Altitude, 2 =
!                Wind Direction, 3 = Wind Velocity, 4 = Density,
!                5 = Temperature, 6 = Pressure
!                Up to J=50 sets of atmospheric data may be entered.

DATA wx/ 300 * 0.0 /

!-----------------------------

END
!      INTEGER*4 FUNCTION HANDL( SIGARGS, MECHARGS )

!-------------------------------------------------------------------------

!  The "subroutine" handl generates the Dump.dat file when an error
!  (math, overflow, etc) is caused by the program/module.

!--Argument Definitions-------------------------------------------------

!  SIGARGS(2)  - (I) Input.
!  MECHARGS(5) - (I) Input.

!-------------------------------------------------------------------------

!      COMMON C(3510)

!      DIMENSION   IC(3510)
!      EQUIVALENCE (C(0001), IC(0001) )

!      INTEGER*4 SIGARGS(2), MECHARGS(5)

!      INCLUDE '($SSDEF)'


!      OPEN( 89, FILE='DUMP.BIN', STATUS='NEW', FORM='BINARY',
!     1           RECORDTYPE='SEGMENTED', ACCESS='SEQUENTIAL',
!     2           ORGANIZATION='SEQUENTIAL' )

!      WRITE(89) C, IC
!      CLOSE (89)

!      WRITE(ID_TABOUT,*)
!      WRITE(ID_TABOUT,*) ' **** WRITE ALL C-LOCATIONS  ON DUMP.DAT ****'
!      WRITE(ID_TABOUT,*) '  USE [ZIPFELP.CADAC]DUMP.EXE TO EXAMINE'
!      WRITE(ID_TABOUT,*) ' THEIR CONTENTS AT THE FATAL ERROR.'
!      WRITE(ID_TABOUT,*)

!      RETURN
!      END

SUBROUTINE amrk

!-------------------------------------------------------------------------

!  Modified EULER numerical integration algorithm:
!   Given:
!           Y' = F( t, y )
!   Estimate Y = F( t, y ) by:
!           w(i+1) =  w(i)  +  h/2(  f[ t(i), w(i) ]
!                              +  f[ t(i+1), w(i) + h f[ t(i), w(i) ] ] )
!   given w(o) = initial value of y.


!-------------------------------------------------------------------------


COMMON  c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

DIMENSION  der(101), ipl(100), v(101)

EQUIVALENCE (c(0001), errval )
EQUIVALENCE (c(0002), errn   )
EQUIVALENCE (c(0003), aerr   )
EQUIVALENCE (c(0004), preloc )
EQUIVALENCE (c(2001), tstage )
EQUIVALENCE (c(2285), nj     )
EQUIVALENCE (c(2664), der(1) )
EQUIVALENCE (c(2562), ipl(1) )
EQUIVALENCE (c(2765), v(1)   )
EQUIVALENCE (c(2866), icoor )

DIMENSION pred(100), OLD(100)
DATA      OLD/ 100 * 0.0 /


!---  Improved Euler method of numerical integration.

!---  Calculate the prediction value:
!         f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]

!     Set the flag to indicate that the predictor loop is being
!     performed.

icoor = 0

DO i = 1, nj
  
!        Load the array with the initial values: f( t(i), w(i) )
  
  OLD(i)  = der(i+1)
  
!        Calculate:  w(i+1) + h f( t(i), w(i) )
  
  v(i+1)  = v(i+1) + OLD(i) * der(1)
  
!        Save these values:  PRED = w(i+1) + h f( t(i), w(i) )
  
  pred(i) = v(i+1)
END DO

!     Increment time to t(i+1):

v(1) = v(1) + der(1)

!     Calculate:  f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]

CALL auxsub

!     Note:  the AUXSUB loads the C array from the V data and
!     reloads the DER array at the end of the module execution.
!     V NOW contains the value: w(i+1) + h f( t(i), w(i) ) after
!            calculations of the function.
!     DER NOW contains the the value:
!             f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]


!---  Corrector loop.

!     Set the flag to indicate the correction loop is being performed.

icoor = 1

!     Compute half the time step:

halfd = der(1) / 2.0

!     Calculate the new value.  This APPEARS to have a sign error in the
!     equation.  However this is just due to the definitions of the
!     variables.  Remember - trying to calculate the following:
!           w(i+1) =  w(i)  +  h/2(  f[ t(1), w(i) ]
!                              +  f[ t(i+1), w(i) + h f[ t(i), w(i) ] ] )
!     At this point in the calculations:
!        V(i)   = w(i+1) + h f( t(i), w(i) )
!        Der(i) = f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]
!        Old(i) = f( t(i), w(i) )
!     Substituting in values:
!     V(i+1) = { w(i+1) + h f( t(i), w(i) ) }
!              + h/2 {  f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]
!                       - f( t(i), w(i) ) }
!     Distribute h/2 and rearrange terms:
!     V(i+1) = w(i+1) + h f( t(i), w(i) ) - (h/2) f( t(i), w(i) )
!                    + (h/2) f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]
!     Subtracting  f( t(i), w(i) ) terms:
!     V(i+1) = w(i+1) + (h/2) f( t(i), w(i) )
!                    + (h/2) f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]
!     Factoring h/2 from both terms giving :
!     V(i+1) = w(i+1) + (h/2) {  f( t(i), w(i) )
!                    + f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]  }

DO i = 1, nj
  v(i+1) = v(i+1) + (der(i+1) - OLD(i)) * halfd
END DO


!---  Perform some integration error checking:

IF( tstage >= 0.1 ) THEN
  
!         Find the integration variable that caused the greatest
!         error for THIS TIME STEP.
  
!         Initialize the error value.
  
  errval = 0
  
  
  DO i = 1, nj
    
!            Skip the elements assigned to the C4 module.
    
    IF( .NOT. ( ipl(i) >= 1100 .AND.  ipl(i) < 1200 ) ) THEN
      
!                Remember:
!                    PRED = w(i+1) + h f( t(i), w(i) ) PRIOR to
!                           calculating the derivative function value.
!                    V(i) = w(i+1) + h f( t(i), w(i) ) AFTER the
!                           calculations of the derivative.
      
      den = AMAX1( ABS( v(i+1) + pred(i) ), 2.0 )
      ERR = ABS( 2.0 * ( v(i+1) - pred(i) ) / den )
      
      
      IF(  ERR  >= errval  ) THEN
        
!                    The error value is bigger than the previous error
!                    Update the error parameters.
        
        errn   = i         ! Integration element number
        aerr   = ipl( i )  ! C element number
        errval = ERR       ! error value
      END IF
    END IF
    
  END DO
  
  
  IF( aerr == preloc ) THEN
    
!             Previous variable producing the max error value.
!             Increment the error counter.
    
    ierrcount = ierrcount + 1
    
    IF( intmsg  .AND.  ierrcount > 100  .AND. preloc /= premessage     ) THEN
      
!                 The variable has been the maximum error for over 100
!                 integration steps AND the message has not been
!                 previously displayed for this variable AND the
!                 integration messages are to be displayed.
      
      WRITE(id_tabout,500) aerr, errval
      IF( tabout ) WRITE(6,500) aerr, errval
      500             FORMAT( 1X, '*** INTEGRATION WARNING ***' /,  &
          4X, 'C LOCATION: ', f7.0, ' generated an', ' error of ', g15.6 )
      
      ierrcount = 1
      
!                 Save the variable number the message was printed for.
      
      premessage = preloc
      
    END IF
    
  ELSE
    
!             New variable causing the max error.
    
    preloc = aerr
    ierrcount = 1
    
  END IF
  
  
END IF


!     Compute the function value:

CALL auxsub

RETURN
END SUBROUTINE amrk

SUBROUTINE auxi

!-------------------------------------------------------------------------

!     This module controls the execution of the initialization modules
!     for the MODULES entered on the type 2 input cards.

!-------------------------------------------------------------------------

LOGICAL :: stgemet

COMMON      c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

DIMENSION   xmodno(99)

EQUIVALENCE (c(2361), nomod )
EQUIVALENCE (c(2362), xmodno(1) )
EQUIVALENCE (c(2561), nip )

nip = 1

!---  Call SWEEP Methodologies
CALL sweepi


DO  i = 1, nomod
  
  
  l = xmodno(i)
  
  GO TO ( 1000, 100, 110, 120, 130, 140, 150, 160,  &
      170, 180, 190, 200, 200, 200, 200, 200,  &
      210, 220, 230, 240, 250, 260, 270, 280,  &
      290, 300, 310, 320, 330, 340, 350, 360 ), l
  
  WRITE(id_tabout,*) '  GOTOER IN AUXI, L  = ',l
  
  
  100    CALL a1i
  CYCLE
  
  110    CALL a2i
  CYCLE
  
  120    CALL a3i
  CYCLE
  
  130    CALL a4i
  CYCLE
  
  140    CALL a5i
  CYCLE
  
  150    CALL c1i
  CYCLE
  
  160    CALL c2i
  CYCLE
  
  170    CALL c3i
  CYCLE
  
  180    CALL c4i
  CYCLE
  
  190    CALL c5i
  CYCLE
  
  200    CONTINUE
  CYCLE
  
  210    CALL d1i
  CYCLE
  
  220    CALL d2i
  CYCLE
  
  230    CALL d3i
  CYCLE
  
  240    CALL d4i
  CYCLE
  
  250    CALL d5i
  CYCLE
  
  260    CONTINUE
  CALL g1i
  CYCLE
  
  270    CALL g2i
  CYCLE
  
  280    CALL g3i
  CYCLE
  
  290    CALL g4i
  CYCLE
  
  300    CALL g5i
  CYCLE
  
  310    CONTINUE
  CYCLE
  
  320    CALL s1i
  CYCLE
  
  330    CALL s2i
  CYCLE
  
  340    CALL s3i
  CYCLE
  
  350    CALL s4i
  CYCLE
  
  360    CALL s5i
  CYCLE
  
END DO


!---  Run the initialization module for G4. (G4 is not a module but
!     determines the end of run.  It is executed in STGE3 and not included
!     in the input list of modules to be executed, therefore the G4I
!     module is not executed so this forces the execution)

CALL g4i


!---  Check to see if output needs to be generated.  Call the
!     output controlling module

stgemet = .false.        ! Output not called after stage met.
CALL oupt3( stgemet )


RETURN
END SUBROUTINE auxi

SUBROUTINE auxsub

!-------------------------------------------------------------------------

!  This module controls the calling of the modules selected by the type
!  2 input cards.

!-------------------------------------------------------------------------

!  NUMSUB - (I) The number of the module entered on the type 2 card.

!-------------------------------------------------------------------------


COMMON        c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /prev/ tprev, cpprev, ppprev

COMMON /krun/  jrun, mulrun, igroup

DIMENSION   xmodno(99)

EQUIVALENCE (c(2000), time      )
EQUIVALENCE (c(2361), nomod     )
EQUIVALENCE (c(2362), xmodno(1) )
EQUIVALENCE (c(2561), nip       )
EQUIVALENCE (c(2020), lconv     )
EQUIVALENCE (c(2001), tstage    )

EQUIVALENCE (c(2866), icoor )

!     Load the C array from the current results of the integration
!     module

CALL ld_carray( nip )


!---  Compute time in stage.

tstage = time - tprev

!---  Evaluate all type 11 variables NOT associated with a user module.
!     These values will be used in the subsequent Module calls.

CALL cntrol( 1, 1 )


!     Call the modules selected by the type 2 cards.

DO  i = 1, nomod
  
!        Lconv = 2 = end of trajectory has been reached; exit this module.
  
  IF( lconv >= 2 ) THEN
    
!           Reset the ISAVE flag is at the end of a set of group runs
    
    IF( jrun >= mulrun ) isave = 0
    
    RETURN
    
  END IF
  
  numsub = xmodno(i)
  
  GO TO ( 500, 110, 120, 130, 140, 150, 160, 170, 180,  &
      190, 200, 210, 210, 210, 210, 210, 220, 230,  &
      240, 250, 260, 270, 280, 290, 300, 310, 320,  &
      330, 340, 350, 360, 380 ),  numsub
  
  WRITE(id_tabout,*) '  GOTOER IN AUXSUB, NUMSUB = ', numsub
  
  
  110    CALL a1
  GO TO 500
  
  120    CALL a2
  GO TO 500
  
  130    CALL a3
  GO TO 500
  
  140    CALL a4
  GO TO 500
  
  150    CALL a5
  GO TO 500
  
  160    CALL c1
  GO TO 500
  
  170    CALL c2
  GO TO 500
  
  180    CALL c3
  GO TO 500
  
  190    CALL c4
  GO TO 500
  
  200    CALL c5
  GO TO 500
  
  210    CONTINUE
  GO TO 500
  
  220    CALL d1
  GO TO 500
  
  230    CALL d2
  GO TO 500
  
  240    CALL d3
  GO TO 500
  
  250    CALL d4
  GO TO 500
  
  260    CALL d5
  GO TO 500
  
  270    CALL g1
  GO TO 500
  
  280    CALL g2
  GO TO 500
  
  290    CALL g3
  GO TO 500
  
  300    CALL g4
  GO TO 500
  
  310    CALL g5
  GO TO 500
  
  320    CONTINUE
  GO TO 500
  
  330    CALL s1
  GO TO 500
  
  340    CALL s2
  GO TO 500
  
  350    CALL s3
  GO TO 500
  
  360    CALL s4
  GO TO 500
  
  380    CALL s5
  GO TO 500
  
  500 CALL cntrol( 0, numsub )
END DO

!     NOTE:  The above call evaluates the type 11 functions associated
!     with particular Modules.  These values will be used the NEXT time
!     the Modules are called;  These new values are also the ones that
!     are output on the tabular/plot data files;  the data precedes it's
!     usage on output.


!     Load the integration arrays from the C array:

CALL ld_deriv( nip )

RETURN
END SUBROUTINE auxsub

SUBROUTINE c1_process( ir2, iswth )

!-------------------------------------------------------------------------

!    Card type 1 : Module Selection: OUPT3 and STGE3
!    These cards select the modules to be executed AFTER EACH
!    INTEGRATION STEP.  The selected module numbers are loaded into the
!    array SUBNO for use in the module that actually calls each module.

!    Only two modules are currently available in this version
!    of CADAC:  #3 = OUPT3 and #4 = STGE3.

!    Card Format:
!      Column       Description
!       1-2         (I) "01" = Card type number
!       4-9         (C) Sub-module Name (Not used)
!       25          (I) Sub-module Number

!--Argument List Definitions--------------------------------------------

!  IR2   - (I) Input. The second integer input on the card = submodule
!          number.
!  ISWTH - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------


!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(OUT)                     :: iswth
COMMON  c(3510)

DIMENSION   subno(99)

EQUIVALENCE (c(2461), nosub    )
EQUIVALENCE (c(2462), subno(1)  )


icardtype = 1

!    Check to insure that there is room in the arrays and the
!    maximum number of modules has not yet been reached.

IF( nosub == 99 ) THEN
  iswth = 1
  CALL oin1_emsg( icardtype )
  RETURN
END IF

!     Check for an invalid module number.

IF( ir2 <= 0  .OR.  ir2 > 9 ) THEN
  iswth = 1
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!     Add the module number to the list to be executed.

nosub = nosub + 1
subno( nosub ) = ir2


RETURN
END SUBROUTINE c1_process

SUBROUTINE c2_process( ir2, iswth )

!-------------------------------------------------------------------------

!  Card type 2:  Module selection cards.  These cards contain the
!  list of module numbers to be executed, in the order of execution.
!  Load the module numbers into the array for selection by the module
!  that controls module exeuction.

!    Card Format:
!      Column       Description
!        1-2         (I) "02" = Card type number
!        3-20        (C) Submodule Name (Not used)
!       21-25        (I) Sub-module  Number

!--Argument List Definitions--------------------------------------------

!  IR2   - (I) Input. The second integer input on the card = sub-module
!          number.
!  ISWTH - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------

!  ICARDTYPE - (I) The card type that is currently being processed.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(OUT)                     :: iswth
COMMON  c(3510)

DIMENSION   xmodno(99)

EQUIVALENCE (c(2361), nomod    )
EQUIVALENCE (c(2362), xmodno(1) )

!     NOMOD = The number of modules to be executed (as input by user)
!     XMODNO(1) = The number of the module to be executed.


icardtype = 2

!     Check to see if the max. number of modules has been reached.

IF( nomod == 98 ) THEN
  iswth = 2
  CALL oin1_emsg( icardtype )
  RETURN
END IF

!     Check for an invalid module number

IF( ir2 <= 0  .OR.  ir2 > 37 ) THEN
  iswth = 2
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!     Add the module to the list.

nomod = nomod + 1
xmodno( nomod ) = ir2


RETURN
END SUBROUTINE c2_process

SUBROUTINE c7_process( ir2, mode, vr, nstage, iswth )

!-------------------------------------------------------------------------

!  Card type 7 : VECTOR Variable initialization Card.  These cards
!  allow values to be assigned to VECTORS in the C common variable.

!    Card Format:
!      Column       Description
!        1-2         (I) "07" = Card type number
!        3-8         (C) Variable Name (Documentation use only)
!        9-14        (C)
!       21-25        (I) Variable Number of first element
!       26-30        (I) Variable Initialization Flag (MODE)
!       31-45        (R) if MODE = 1;  value of all elements.
!       46-60        (R) SET by CADAC;  Points to the location in
!                        the storage array to the data.
!       61-62        (I) Stage number for multi run cases.

!--Argument List Definitions--------------------------------------------

!  IR2    - (I) Input. The second integer input on the card = submodule
!               number.
!  VR(I)  - (R) Input. The two real values input on the card.
!  MODE   - (I) Input. The number of variables in the array as a + or -
!               value as a flag for variable initialization.
!  NSTAGE - (I) Input.  The number of the stage currently being
!               processed.
!  ISWTH  - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------

!  ICARDTYPE - (I) The card type that is currently being processed.

!-------------------------------------------------------------------------



INTEGER, INTENT(IN OUT)                  :: ir2
INTEGER, INTENT(IN)                      :: mode
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(IN)                      :: nstage
INTEGER, INTENT(OUT)                     :: iswth
COMMON /c7wkd/  iwc7s0, wc7s0(10,20), iwc7sn(20), wc7sn(20,5,20)

COMMON  c(3510)





icardtype = 7


!     Check for an invalid variable number (C location) to be
!     initialized.

IF( ir2 <= 0  .OR.  ir2 > 3510 ) THEN
  iswth = 7
  CALL oin1_emsg( icardtype )
  RETURN
END IF


IF( mode > 0 ) THEN
  
!         Initialize the elements to individual values.
  
  iset = INT( vr(2) )
  
  IF( nstage < 1 ) THEN
    
    DO i = 1, mode
      c( ir2 + ( i-1 ) ) = wc7s0( iset, i )
    END DO
    
  ELSE
    
    DO i = 1, mode
      c( ir2 + ( i-1 ) ) =  wc7sn( nstage, iset, i )
    END DO
  END IF
  
ELSE
  
!         Mode < 0:  Initialize elements to same value.
  
  nelements = ABS( mode )
  
  DO i = 1, nelements
    c( ir2 + ( i-1 ) ) = vr(1)
  END DO
  
END IF


RETURN
END SUBROUTINE c7_process

SUBROUTINE c8_process

!-------------------------------------------------------------------------

!   Card type 8 : Read and set up weather data.  Display the data to
!   the output file.


!    Card Format:
!      Column       Description
!        1-2         (I) "08" = Card type number

!    Card Format of following weather deck (Max of 50 cards):
!        Free field format on each record with the information in the
!        following order (values must be entered for all parameters):
!             Altitude (Ft-ASL), Wind direction (Deg),
!             Wind Velocity (Ft/Sec), Density (Slugs/Ft**3),
!             Temperature (Deg F), Pressure (Lb/Ft**2)

!   Metric units are respectively: ( M-ASL), (Deg), (M/Sec), (Kg/M**3),
!             (Deg C), (Pascals)


!--Local Variable Definitions-------------------------------------------

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /winds/  walt(50), wdir(50), wvel(50), rhx(50),  &
    ctmp(50), wpres(50), kountw, rhw

COMMON /wsetwt/ wx(6,50)


EQUIVALENCE (c(0053), optmet    )


!---  Write the weather headers:

WRITE(id_tabout,440)
440 FORMAT( / '****  WEATHER DATA  ****', //  &
    '   ALTITUDE ', '  WIND DIR  ', '  WIND VEL  ',  &
    '  DENSITY   ',  '  TEMPRTR   ', '  PRESSURE  ' )


IF( optmet < 1.0 ) THEN
  
!         English units - write appropriate headers.
  
  WRITE(id_tabout,460)
  460     FORMAT( '  FEET,MSL  ', '  DEGREES   ', '  FT/SEC   ',  &
      '  SLG/FT**3 ',  '  DEG FAR   ', '  LB/FT**2  ' )
  
ELSE
  
!         Metric Units - Write appropriate headers.
  
  WRITE(id_tabout,500)
  500     FORMAT(  '  METERS,MSL', '  DEGREES   ', '  METERS/SEC',  &
      '  KG/M**3   ',  '  DEG CENT  ', '  PASCALS   ' )
  
END IF


!     Load the working arrays from the data input arrays.

DO i = 1, kountw
  walt(i)  = wx(1,i)
  wdir(i)  = wx(2,i)
  wvel(i)  = wx(3,i)
  rhx(i)   = wx(4,i)
  ctmp(i)  = wx(5,i)
  wpres(i) = wx(6,i)
  
  rhw   = walt(i)
  
  WRITE(id_tabout,540) walt(i),wdir(i),wvel(i),rhx(i),ctmp(i),wpres(i)
  540    FORMAT( 1X, 1P6E12.3 )
  
END DO

WRITE(id_tabout,*) '   '
WRITE(id_tabout,*) '****  END OF WEATHER DATA  ****'
WRITE(id_tabout,*) '   '


RETURN
END SUBROUTINE c8_process

SUBROUTINE c9_process( ir2 )

!-------------------------------------------------------------------------

!  Header cards.  This module allows up to 5 cards of text data to be
!  entered and displayed on the output.

!    Card Format:
!      Column       Description
!        1-2         (I) "09" = Card type number
!        25          (I) Number of header cards that follow ( N <= 5)

!    Header Card Format:
!      Column       Description
!      1-80         (C) Text to be saved and displayed.

!--Argument List Definitions--------------------------------------------

!  IR2   - (I) Input. The second integer input on the card = Number of
!          header cards following.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
COMMON /coller/ hol(5)
CHARACTER (LEN=80) :: hol

COMMON /wsetc/  al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al


numhol = ir2

DO ix = 1, numhol
  hol(ix) = holl(ix)
END DO


RETURN
END SUBROUTINE c9_process

SUBROUTINE c10_process( ir2, iswth )

!-------------------------------------------------------------------------

!  This module process the data entered on the record(s) following a type 10
!  card.  This record contains the conditions for staging.  A maximum of
!  two staging tests/variables/records may be entered.

!-------------------------------------------------------------------------

!  IR2 - (I) Input. The number of staging tests/variables entered on the
!            type 10 card.
!  ISWTH - (I) Output.  Error flag set as necessary by this module.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(OUT)                     :: iswth
COMMON  c(3510)


COMMON /stage/   loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest

COMMON /stage1/  istage, numstage

COMMON /stagec/  name1(2), name2(2)
CHARACTER (LEN=6) :: name2 chara ter*6 name1

COMMON /wsetsc/  mcri(20,2,4), wval(20,2)

COMMON /wsetscc/ mcric(20,2,2)
CHARACTER (LEN=6) :: mcric



ntest  = ir2
IF( ntest /= 1  .AND.  ntest /= 2 ) ntest = 1

!     Increment stage number

numstage = numstage + 1

DO i = 1, ntest
  
!            Transfer staging criteria data to the actual working arrays.
  
  name1(i) = mcric( numstage, i, 1 )   ! Stage Variable Name
  loc(i)   = mcri( numstage, i, 1 )    ! C Element location
  incrs(i) = mcri( numstage, i, 2 )    ! Flag
  name2(i) = mcric( numstage, i, 2 )   !
  val(i)   = wval( numstage, i )       ! Real data value
  units(i) = mcri( numstage, i, 3 )    ! ?
  kode(i)  = mcri( numstage, i, 4 )    ! Kode flag
  
!            Check for an invalid C element location
  
  IF( loc(i) <= 0 .OR. loc(i) > 3510 ) iswth = 10
  
!            Check for an invalid staging flag
  
  IF( IABS( incrs(i) ) > 1 ) iswth = 10
  
!            Check for an invalid KODE flag:
  
  IF( kode(i) > 1 ) iswth = 10
  
  IF( kode(i) == 1 ) THEN
    
!                VAL contains a C element location.
!                Check for invalid C element location
    
    IF( val(i) < 1.0  .OR.  val(i) > 3510.0 ) iswth = 10
  END IF
  
  
  l = loc(i)    ! C element location of the staging variable
  
  IF( kode(i) < 0 ) THEN
    
!                Add the value VAL to the current contents of the C
!                element location specified in LOC.  During simulation,
!                this sum, TEST, is compared to the contents of the
!                element specified in LOC to determine staging.
    
    test(i) = c(l) + val(i)
    
  ELSE IF( kode(i) > 0 ) THEN
    
!                The contents of the C element location is to be used as
!                the staging criteria.
    
    loct(i) = val(i)
    
  ELSE
    
!                The value, VAL, is to be used as the stage criteria
    
    test(i) = val(i)
    
  END IF
  
!            If time is the staging variable, decrease the test value
!            slightly.
  
  IF( l == 2000 ) test(i) = test(i) - 0.000001
  
END DO


RETURN
END SUBROUTINE c10_process

SUBROUTINE c11_process( ir2, alpha, vr, iswth, ir3 )

!-------------------------------------------------------------------------
!  This module performs the processing for data input with card type
!  11.

!    Card Format:
!      Column       Description
!       1-2         (I) "11" = Card type number
!       3-8         (C) Name of the controlled variable (Not used)
!       9           (C) Combination Code.  Must be either: ' ', '=',
!                       '+', '*', '-'
!       10-14       (C) Name of function
!       15-20       (C) Not used
!       21-25       (I) C Element number of the controlled variable. IR2
!       26-30       (I) Activated under task SEU 91-02 - Definition
!                       depends on the function's definition.  Not
!                       used for most functions. IR3
!       31-45       (R) 1st parameter.  If zero or blank, the current
!                       value will be used.
!       46-60       (R) 2nd parameter.


!--Argument List Definitions--------------------------------------------

!  IR2      - (I) Input. The second integer input on the card =
!              controlled variable number.
!  ALPHA(3) - (C) Input. All of the character data input on the card
!             type 11
!  VR(2)    - (R) Input. Both real variables input on the card.
!  ISWTH    - (I) Output. Input Error flag.
!  IR3      - (I) Input. The third integer input on the card.  Use
!             depends on the function definition.

!--Local Variable Definitions-------------------------------------------

!  CCODE(5)  - (C1) The combination codes in character format.
!  CHRCODE   - (C1) The character code entered by the user.
!  CHRFUNCT  - (C5) The function type entered by the user in character
!              format.
!  FUNCT(14) - (C5) The keywords for the available function types.
!  ICARDTYPE - (I) The card type that is currently being processed.
!  ICODE     - (I) The combination code deciphered and in integer
!              format.
!  NUMFUNCT  - (I) The maximum number of available functions.  Also the
!              array size of FUNCT.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: ir2
CHARACTER (LEN=1), INTENT(IN)            :: alpha(3)
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(OUT)                     :: iswth
INTEGER, INTENT(IN)                      :: ir3
COMMON  c(3510)

COMMON /ccom/ icf(25), icc(25), icl(25), ca(25), cl(25), ct0(25), nc, icl2(25)


EQUIVALENCE (c(2000), time )



CHARACTER (LEN=1) :: *6, chrcode*1, chrfunct*5, funct(15)*5, ccode(5)*1


DATA ccode/ ' ',  '=',  '+',  '-',  '*'  /,  &
    funct/ 'STEP ', 'RAMP ', 'PARAB', 'SIN  ', 'COS  ',  &
'TRI  ', 'GAUSS', 'UNIF ', 'DECAY', 'SQR  ',  &
    'SUM  ', 'PROD ', 'DIFF ', 'RAYLE', 'EQUAL'  /, numfunct/ 15 /



icardtype = 11


!---  Parse the combination code and the type function from the input
!     character string.

chrcode = alpha(2)(1:1)
chrfunct = alpha(2)(2:6)


IF( chrfunct == 'END  ' ) THEN

!         END function selected - Deactivate all control functions

nc = 0

RETURN
END IF


!---  Check for an invalid C element location entered in IR2

IF( ir2 <= 0  .AND.  ir2 > 3510 ) THEN
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Determine the combination code.

icode = 0
DO  i = 1, 5
  IF( chrcode == ccode(i) ) icode = i
END DO

IF( icode == 0 ) THEN
  
!         Invalid combination code entered.
  
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Determine the function type.

ifunct = 0
DO i = 1, numfunct
  IF( chrfunct == funct(i) ) ifunct = i
END DO

IF( ifunct == 0 ) THEN
  
!         Invalid function type - Exit the module with an error message.
  
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


IF( ifunct > 10  .AND.  ifunct < 14 ) THEN
  
!         Sum, Diff or Prod functions were selected.  The last two Real
!         variables input must contain C element locations.  Insure that
!         valid C locations are entered in these variables.
  
  DO i = 1, 2
    IF( vr(i) <= 0.0  .OR.  vr(i) > 3510.0 ) THEN
      iswth = 11
      CALL oin1_emsg( icardtype )
      RETURN
    END IF
  END DO
  
ELSE IF( ifunct == 15 ) THEN
  
!         The equal function was selected.  The first Real variable
!         input must contain a C element location.  Insure that
!         a valid C locations is entered.
  
  IF( vr(1) <= 0.0  .OR.  vr(1) > 3510.0 ) THEN
    iswth = 11
    CALL oin1_emsg( icardtype )
    RETURN
  END IF
END IF

!---

IF( nc == 25 ) THEN
  
!         Maximum number of functions have been defined.  Don't allow
!         any more definitions.  Give error message and return.
  
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Valid data has been input.  Define the functions.

nc      = nc + 1      ! Increment the number of defined functions.

!     Store the input data in their respective arrays:

icf(nc) = ifunct      ! Function Type
icc(nc) = icode       ! Combination Code
icl(nc) = ir2         ! Controlled variable
icl2(nc) = ir3        ! Integer parameter

!     Store the first variable or, if 0.0 was entered, save the current
!     value of the controlling variable.

ca(nc)  = vr(1)       ! 1st parameter
IF( ca(nc) == 0.0  )  ca(nc) = c( ir2 )

cl(nc)  = vr(2)       ! 2nd parameter
ct0(nc) = time        ! Current time at function definition


IF( ifunct == 7 ) THEN
  
!         GAUSS function selected - initialize CT0 to 0.0 and apply the
!         negative to the beta at this point.  A = EXP( -Beta * DT)
!         where Beta is the 2nd parameter input.
  
  ct0(nc) = 0.0
  cl(nc)  =  - ABS( cl(nc) )
  
ELSE IF( ifunct == 14 ) THEN
  
!         RAYLE function selected - The integer parameter is the number
!         of integration intervals the value of the function is to be
!         maintained (ie like a step width).  Insure that this variable
!         is greater than zero. If the variable is zero, force a
!         default value of 5.
  
  IF( icl2(nc) <= 0.0 ) icl2( nc ) = 5
  
!         Also set the CT0 definition for this function.  CT0 is the
!         time where the next obstical is to be encountered = Current
!         time at function definition + delta time until the next obstical
!         is encountered.
  
  emean = ca(nc)            ! 1st parameter
  deltobs = expon( emean )  ! Time between obsticals in seconds.
  
!         Add this to the current time already stored in Ct0.
  
  ct0( nc ) = ct0( nc ) + deltobs
  
ELSE IF( ifunct == 15 ) THEN
  
!         EQUAL function - Go ahead and set the initial value of
!         this function.  This is to prevent the function from having an
!         incorrect value during the time between the function's initiation
!         and the first function evaluation.
  
  k1 = vr(1)               ! Intergerize the element number
  c( ir2 ) = c( k1 )       ! Get the current value.
  
  
END IF



RETURN
END SUBROUTINE c11_process

SUBROUTINE c90_process

!-------------------------------------------------------------------------

!   Type 90 card stores state on file -tape90-
!   Type 91 card restores state from file -tape90-
!   Routine loaded inline.

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /oindat/  j16, icd, i16

COMMON /stage1/  istage, numstage

DIMENSION ic(3510)
EQUIVALENCE (c(0001), ic(0001) )
!---
!------------------------PC Code-------------------------------------
!---
OPEN( id_csave, FILE='CSAVE.ASC', STATUS='UNKNOWN' )
WRITE(id_csave,*) c, ic

CLOSE( id_csave )

!--------------------------------------------------------------------

!     Write a message to the output file.

WRITE(id_tabout,*) ' WRITE ON CSAVE.ASC '  ! TAPE90 '

!     End routine loaded inline.
!     Store the stage number where the save occurred, save the card number
!     and set the save flag

ibegin = numstage
icard  = icd
isave  = 1


RETURN
END SUBROUTINE c90_process

SUBROUTINE comprt

!-------------------------------------------------------------------------


!-------------------------------------------------------------------------

COMMON      c(3510)

RETURN
END SUBROUTINE comprt

